#!/usr/bin/perl 
use strict;
use Getopt::Long;
use DBI;
################################################################################
## Kontrollkit
## NAME: mt-qcache-fragmentation.pl
## DATE: 2008-10-01
## AUTHOR: Matt Reid
## WEBSITE: http://kontrollsoft.com
## EMAIL: themattreid@gmail.com
## LICENSE: BSD http://www.opensource.org/licenses/bsd-license.php
################################################################################
## Copyright 2008 Matt Reid
## All rights reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions
# are met:
# 1. Redistributions of source code must retain the above copyright
#    notice, this list of conditions and the following disclaimer.
# 2. Redistributions in binary form must reproduce the above copyright
#    notice, this list of conditions and the following disclaimer in the
#    documentation and/or other materials provided with the distribution.
# 3. The name of the author may not be used to endorse or promote products
#    derived from this software without specific prior written permission.
#
# THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
# IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
# OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
# IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,
# INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
# NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
# DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
# THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
# THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
##################################################################################
#
## WHAT THIS SCRIPT DOES #########################################################
#This script checks flushes tables in sequence and then runs a global flush
###########################################
#Set your options here please
###########################################
my $opt = {
                'host' => 'localhost',
                'user' => 'root',
                'pass' => 'password'
};

my $email = "yes"; #set to "yes" or "no" to enable email notification
my $emailaddr = "email\@email.com"; # remember to use a \ in front of the @ sign: email\@email.com

# Set the following to "yes" or "no" if you want the query cache to be automatically
# flushed if it needs to be.
my $autoflush = "yes"; 

## END OF USER SETTINGS
###########################################
#
GetOptions($opt, "host=s", "c=i", "w=i", "user=s", "pass=s", "help");

sub emailer {
    my $host = `/bin/echo \$HOSTNAME`;
    my ($fragHR,$defrag) = @_;
    my $subject = "The query cache on server: $host was at $fragHR% fragmentation. It has $defrag.";
    system("/bin/echo \"$subject\" > /tmp/mt-qcache-fragmentation-report.tmp");
    system("/bin/mail -s 'mt-qcache-fragmentation.pl report' $emailaddr < /tmp/mt-qcache-fragmentation-report.tmp");
    system("/bin/rm -f /tmp/mt-qcache-fragmentation-report.tmp");
}

sub flush {
    my $HOST = $opt>{'host'};
    my $USER = $opt->{'user'};
    my $PASS = $opt->{'pass'};
    my $free = undef;
    my $total = undef;
    my $frag = undef;
    my $fragHR = undef;

    print "\nConnecting to database...\n";
    my $dbh = DBI->connect("DBI:mysql:host=$HOST",$USER,$PASS) or die "CRIT: cannot connect to $HOST. Exiting.";
    if (not $dbh) {
        print "CRIT: cannot connect to $HOST";
        exit 1;
    }
    print "Checking query cache values...\n\n";

    my $sql = "show global status like 'qcache%';";
    my $sth = $dbh->prepare($sql) or die "mysql connect failed";
    $sth->execute or die "executing: ", $dbh->errstr;

    while (my $row = $sth->fetchrow_hashref) {
	my $name = $row->{'Variable_name'};
        my $value = $row->{'Value'};

	if($name == "Qcache_free_blocks") { $free = $value};
	if($name == "Qcache_total_blocks") { $total = $value};
    }
    print "Query cache free blocks: $free\n";
    print "Query cache total block: $total\n";
    
    if (($free > 2) && ($total > 0)) {
	$frag=($free * 100 / $total);
	$fragHR = sprintf("%.2f", $frag);
	
	if ($fragHR > 20) {
	    print "The query cache is $fragHR % fragmented\n";
	    print "Run \"FLUSH QUERY CACHE\" to defragment the query cache\n";
	    print "You can decrease the query_cache_min_res_unit variable if you run many small queries\n";
	    if ($autoflush == "yes") {
		print "Auto flush set to 'yes', flushing query cache...\n";
		$dbh->do("FLUSH QUERY CACHE");
		print "Cache flushed.\n";
		if($email == "yes") { emailer($fragHR,"been defragmented");}
	    }
	    else {
		if($email == "yes") { emailer($fragHR,"not been defragmented");}
	    }
	}
	else {
	    print "The query cache is $fragHR % fragmented.\n";
	    print "No action is needed at this time.\n";
	    if($email == "yes") { emailer($fragHR,"not been defragmented");}
	}
    }
    else {
        $fragHR = 0;
	print "The query cache is not fragmented.\n";
	print "No action is needed at this time.\n";
	if($email == "yes") { emailer($fragHR,"not been defragmented");}
    }
}    

print<<HELP;
-------------------------------------------------
mt-qcache-fragmentation.pl
Kontrollkit
http://kontrollsoft.com
2008-10-15                               
This script checks for query cache fragmentation
-------------------------------------------------
    Script will run in 5 seconds...
HELP

system("sleep 5");
flush();
